home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / Picclip.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  8.3 KB  |  304 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. unit PicClip;
  13.  
  14. interface
  15.  
  16. {$I RX.INC}
  17.  
  18. uses Messages, Classes, Controls, Windows, RTLConsts, Graphics;
  19.  
  20. type
  21.  
  22. { TPicClip }
  23.   TCellRange = 1..MaxInt;
  24.  
  25.   TPicClip = class(TComponent)
  26.   private
  27.     FPicture: TPicture;
  28.     FRows: TCellRange;
  29.     FCols: TCellRange;
  30.     FBitmap: TBitmap;
  31.     FMasked: Boolean;
  32.     FMaskColor: TColor;
  33.     FOnChange: TNotifyEvent;
  34.     procedure CheckIndex(Index: Integer);
  35.     function GetCell(Col, Row: Cardinal): TBitmap;
  36.     function GetGraphicCell(Index: Integer): TBitmap;
  37.     function GetDefaultMaskColor: TColor;
  38.     function GetIsEmpty: Boolean;
  39.     function GetCount: Integer;
  40.     function GetHeight: Integer;
  41.     function GetWidth: Integer;
  42.     function IsMaskStored: Boolean;
  43.     procedure PictureChanged(Sender: TObject);
  44.     procedure SetHeight(Value: Integer);
  45.     procedure SetPicture(Value: TPicture);
  46.     procedure SetWidth(Value: Integer);
  47.     procedure SetMaskColor(Value: TColor);
  48.   protected
  49.     procedure AssignTo(Dest: TPersistent); override;
  50.     procedure Changed; dynamic;
  51.   public
  52.     constructor Create(AOwner: TComponent); override;
  53.     destructor Destroy; override;
  54.     procedure Assign(Source: TPersistent); override;
  55.     function GetIndex(Col, Row: Cardinal): Integer;
  56.     procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);
  57.     procedure DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
  58.     procedure LoadBitmapRes(Instance: THandle; ResID: PChar);
  59.     property Cells[Col, Row: Cardinal]: TBitmap read GetCell;
  60.     property GraphicCell[Index: Integer]: TBitmap read GetGraphicCell;
  61.     property IsEmpty: Boolean read GetIsEmpty;
  62.     property Count: Integer read GetCount;
  63.   published
  64.     property Cols: TCellRange read FCols write FCols default 1;
  65.     property Height: Integer read GetHeight write SetHeight stored False;
  66.     property Masked: Boolean read FMasked write FMasked default True;
  67.     property Rows: TCellRange read FRows write FRows default 1;
  68.     property Picture: TPicture read FPicture write SetPicture;
  69.     property MaskColor: TColor read FMaskColor write SetMaskColor stored IsMaskStored;
  70.     property Width: Integer read GetWidth write SetWidth stored False;
  71.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  72.   end;
  73.  
  74. implementation
  75.  
  76. {$B-}
  77.  
  78. uses SysUtils, VCLUtils, Consts, RXConst;
  79.  
  80. { TPicClip }
  81.  
  82. constructor TPicClip.Create(AOwner: TComponent);
  83. begin
  84.   inherited Create(AOwner);
  85.   FPicture := TPicture.Create;
  86.   FPicture.OnChange := PictureChanged;
  87.   FBitmap := TBitmap.Create;
  88.   FRows := 1;
  89.   FCols := 1;
  90.   FMaskColor := GetDefaultMaskColor;
  91.   FMasked := True;
  92. end;
  93.  
  94. destructor TPicClip.Destroy;
  95. begin
  96.   FOnChange := nil;
  97.   FPicture.OnChange := nil;
  98.   FBitmap.Free;
  99.   FPicture.Free;
  100.   inherited Destroy;
  101. end;
  102.  
  103. procedure TPicClip.Assign(Source: TPersistent);
  104. begin
  105.   if Source is TPicClip then begin
  106.     with TPicClip(Source) do begin
  107.       Self.FRows := Rows;
  108.       Self.FCols := Cols;
  109.       Self.FMasked := Masked;
  110.       Self.FMaskColor := MaskColor;
  111.       Self.FPicture.Assign(FPicture);
  112.     end;
  113.   end
  114.   else if (Source is TPicture) or (Source is TGraphic) then
  115.     FPicture.Assign(Source)
  116.   else inherited Assign(Source);
  117. end;
  118.  
  119. {$IFDEF WIN32}
  120. type
  121.   THack = class(TImageList);
  122. {$ENDIF}
  123.  
  124. procedure TPicClip.AssignTo(Dest: TPersistent);
  125. {$IFDEF WIN32}
  126. var
  127.   I: Integer;
  128.   SaveChange: TNotifyEvent;
  129. {$ENDIF}
  130. begin
  131.   if (Dest is TPicture) then Dest.Assign(FPicture)
  132.   else if (Dest is TGraphic) and (FPicture.Graphic <> nil) and
  133.     (FPicture.Graphic is TGraphic(Dest).ClassType) then
  134.     Dest.Assign(FPicture.Graphic)
  135. {$IFDEF WIN32}
  136.   else if (Dest is TImageList) and not IsEmpty then begin
  137.     with TImageList(Dest) do begin
  138.       SaveChange := OnChange;
  139.       try
  140.         OnChange := nil;
  141.         Clear;
  142.         Width := Self.Width;
  143.         Height := Self.Height;
  144.         for I := 0 to Self.Count - 1 do begin
  145.           if Self.Masked and (MaskColor <> clNone) then
  146.             TImageList(Dest).AddMasked(GraphicCell[I], MaskColor)
  147.           else TImageList(Dest).Add(GraphicCell[I], nil);
  148.         end;
  149.         Masked := Self.Masked;
  150.       finally
  151.         OnChange := SaveChange;
  152.       end;
  153.       THack(Dest).Change;
  154.     end;
  155.   end
  156. {$ENDIF}
  157.   else inherited AssignTo(Dest);
  158. end;
  159.  
  160. procedure TPicClip.Changed;
  161. begin
  162.   if Assigned(FOnChange) then FOnChange(Self);
  163. end;
  164.  
  165. function TPicClip.GetIsEmpty: Boolean;
  166. begin
  167.   Result := (Picture.Graphic = nil) or Picture.Graphic.Empty;
  168. end;
  169.  
  170. function TPicClip.GetCount: Integer;
  171. begin
  172.   if IsEmpty then Result := 0
  173.   else Result := Cols * Rows;
  174. end;
  175.  
  176. procedure TPicClip.Draw(Canvas: TCanvas; X, Y, Index: Integer);
  177. var
  178.   Image: TGraphic;
  179. begin
  180.   if Index < 0 then Image := Picture.Graphic
  181.   else Image := GraphicCell[Index];
  182.   if (Image <> nil) and not Image.Empty then begin
  183.     if FMasked and (FMaskColor <> clNone) and
  184.       (Picture.Graphic is TBitmap) then
  185.       DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image), FMaskColor)
  186.     else Canvas.Draw(X, Y, Image);
  187.   end;
  188. end;
  189.  
  190. procedure TPicClip.DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
  191. var
  192.   X, Y: Integer;
  193. begin
  194.   X := (Rect.Left + Rect.Right - Width) div 2;
  195.   Y := (Rect.Bottom + Rect.Top - Height) div 2;
  196.   Draw(Canvas, X, Y, Index);
  197. end;
  198.  
  199. procedure TPicClip.LoadBitmapRes(Instance: THandle; ResID: PChar);
  200. var
  201.   Bmp: TBitmap;
  202. begin
  203.   Bmp := MakeModuleBitmap(Instance, ResID);
  204.   try
  205.     Picture.Assign(Bmp);
  206.   finally
  207.     Bmp.Free;
  208.   end;
  209. end;
  210.  
  211. procedure TPicClip.CheckIndex(Index: Integer);
  212. begin
  213.   if (Index >= Cols * Rows) or (Index < 0) then
  214. {$IFDEF RX_D3}
  215.     raise EListError.CreateFmt(SListIndexError, [Index]);
  216. {$ELSE}
  217.     raise EListError.CreateFmt('%s (%d)', [LoadStr(SListIndexError), Index]);
  218. {$ENDIF}
  219. end;
  220.  
  221. function TPicClip.GetIndex(Col, Row: Cardinal): Integer;
  222. begin
  223.   Result := Col + (Row * Cols);
  224.   if (Result >= Cols * Rows) or IsEmpty then Result := -1;
  225. end;
  226.  
  227. function TPicClip.GetCell(Col, Row: Cardinal): TBitmap;
  228. begin
  229.   Result := GetGraphicCell(GetIndex(Col, Row));
  230. end;
  231.  
  232. function TPicClip.GetGraphicCell(Index: Integer): TBitmap;
  233. begin
  234.   CheckIndex(Index);
  235.   AssignBitmapCell(Picture.Graphic, FBitmap, Cols, Rows, Index);
  236. {$IFDEF RX_D3}
  237.   if Picture.Graphic is TBitmap then
  238.     if FBitmap.PixelFormat <> pfDevice then
  239.       FBitmap.PixelFormat := TBitmap(Picture.Graphic).PixelFormat;
  240.   FBitmap.TransparentColor := FMaskColor or PaletteMask;
  241.   FBitmap.Transparent := (FMaskColor <> clNone) and Masked;
  242. {$ELSE}
  243.   if Masked and (FMaskColor <> clNone) then
  244.     with FBitmap do
  245.       if not Empty then Canvas.Pixels[0, Height - 1] := FMaskColor;
  246. {$ENDIF}
  247.   Result := FBitmap;
  248. end;
  249.  
  250. function TPicClip.GetDefaultMaskColor: TColor;
  251. begin
  252.   Result := clOlive;
  253.   if (Picture.Graphic <> nil) and (Picture.Graphic is TBitmap) then
  254.     Result := TBitmap(Picture.Graphic).TransparentColor and
  255.       not PaletteMask;
  256. end;
  257.  
  258. function TPicClip.GetHeight: Integer;
  259. begin
  260.   Result := Picture.Height div FRows;
  261. end;
  262.  
  263. function TPicClip.GetWidth: Integer;
  264. begin
  265.   Result := Picture.Width div FCols;
  266. end;
  267.  
  268. function TPicClip.IsMaskStored: Boolean;
  269. begin
  270.   Result := MaskColor <> GetDefaultMaskColor;
  271. end;
  272.  
  273. procedure TPicClip.SetMaskColor(Value: TColor);
  274. begin
  275.   if Value <> FMaskColor then begin
  276.     FMaskColor := Value;
  277.     Changed;
  278.   end;
  279. end;
  280.  
  281. procedure TPicClip.PictureChanged(Sender: TObject);
  282. begin
  283.   FMaskColor := GetDefaultMaskColor;
  284.   if not (csReading in ComponentState) then Changed;
  285. end;
  286.  
  287. procedure TPicClip.SetHeight(Value: Integer);
  288. begin
  289.   if (Value > 0) and (Picture.Height div Value > 0) then
  290.     Rows := Picture.Height div Value;
  291. end;
  292.  
  293. procedure TPicClip.SetWidth(Value: Integer);
  294. begin
  295.   if (Value > 0) and (Picture.Width div Value > 0) then
  296.     Cols := Picture.Width div Value;
  297. end;
  298.  
  299. procedure TPicClip.SetPicture(Value: TPicture);
  300. begin
  301.   FPicture.Assign(Value);
  302. end;
  303.  
  304. end.